home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / DATABASE / OBJ1_2.ZIP;1 / ERRORSYS.PRG < prev    next >
Encoding:
Text File  |  1992-12-28  |  6.8 KB  |  301 lines
  1. /***
  2. *    Errorsys.prg
  3. *    Standard Clipper 5.0 error handler
  4. *    Copyright (c) 1990 Nantucket Corp.  All rights reserved.
  5. *
  6. *       Modified by JHK, JHK-Software, Piestany.
  7. *
  8. *    Compile:  /m/n/w
  9. */
  10.  
  11. #include "error.ch"
  12. #include "fileio.ch"
  13.  
  14. // put messages to STDERR
  15. #command ? <list,...>   =>  ?? Chr(13) + Chr(10) ; ?? <list>
  16. #command ?? <list,...>  =>  OutErr(<list>)
  17.  
  18.  
  19. // used below
  20. #define NTRIM(n)            ( LTrim(Str(n)) )
  21. #define CR_LF               (chr(13)+chr(10))
  22.  
  23.  
  24. static ErrFile:=""          //new ƒƒø
  25. static BreakStack:={}       //new ƒƒ¡ƒ>> JHK
  26.  
  27.  
  28. //*****************************************************************************
  29. // see Object.ch break exception
  30. //
  31. procedure PushBreak(Br)
  32.   AAdd(BreakStack,Br)
  33.   return
  34.  
  35. function TopBreak()
  36.   return(ATail(BreakStack))
  37.  
  38. function PopBreak()
  39.   return(ATailDel(BreakStack))
  40.  
  41. procedure DoBreak(o)
  42.   break o; return
  43.  
  44.  
  45. /***
  46. *       ErrorSys()
  47. *
  48. *       Note:  automatically executes at startup
  49. */
  50. procedure ErrorSys()
  51.   ErrorBlock({|e|Abort(e)}); return
  52.  
  53.  
  54.  
  55. //*****************************************************************************
  56. // UserID( cUserID )
  57. // UserNo( nRecNo_in_database_(cIFR) )
  58. // UserLevel( nLevel_for_programmer_(defined_by_supervisor) )
  59. //
  60. function UserID(new)
  61.   static old:=""
  62.   local tmp:=old
  63.   if !Empty(new); old:=AllTrim(new); endif
  64.   return(tmp)
  65.  
  66. function UserNo(new)
  67.   static old:=0
  68.   local tmp:=old
  69.   if !Empty(new); old:=new; endif
  70.   return(tmp)
  71.  
  72. function UserLevel(new)
  73.   static old:=0
  74.   local tmp:=old
  75.   if !Empty(new); old:=new; endif
  76.   return(tmp)
  77.  
  78.  
  79.  
  80. /***
  81. *       Abort()
  82. */
  83. function Abort(e)
  84. local i, cMessage, aOptions, nChoice, cDateTime, fhandle, nFirstProc
  85.  
  86.  
  87.         if ValType(e)=="C"   //build error message
  88.  
  89.           cMessage:="Error OBJECT/ABORT  "+e
  90.           Alert(cMessage,{"Quit"})
  91.           nFirstProc:=1
  92.  
  93.         else //standart clipper message
  94.  
  95.           //first procedure (called from...)
  96.           nFirstProc:=2
  97.  
  98.           // by default, division by zero yields zero
  99.           if ( e:genCode == EG_ZERODIV )
  100.                   return (0)
  101.           end
  102.  
  103.  
  104.           // for network open error, set NETERR() and subsystem default
  105.           if ( e:genCode == EG_OPEN .and. e:osCode == 32 .and. e:canDefault )
  106.  
  107.                   NetErr(.t.)
  108.                   return (.f.)                                                                    // NOTE
  109.  
  110.           end
  111.  
  112.  
  113.           // for lock error during APPEND BLANK, set NETERR() and subsystem default
  114.           if ( e:genCode == EG_APPENDLOCK .and. e:canDefault )
  115.  
  116.                   NetErr(.t.)
  117.                   return (.f.)                                                                    // NOTE
  118.  
  119.           end
  120.  
  121.  
  122.  
  123.           // build error message
  124.           cMessage := ErrorMessage(e)
  125.  
  126.  
  127.           // build options array
  128.           // aOptions := {"Break", "Quit"}
  129.           aOptions := {"Quit"}
  130.  
  131.           if (e:canRetry)
  132.                   AAdd(aOptions, "Retry")
  133.           end
  134.  
  135.           if (e:canDefault)
  136.                   AAdd(aOptions, "Default")
  137.           end
  138.  
  139.  
  140.           // put up alert box
  141.           nChoice := 0
  142.           while ( nChoice == 0 )
  143.  
  144.                   if ( Empty(e:osCode) )
  145.                           nChoice := Alert( cMessage, aOptions )
  146.  
  147.                   else
  148.                           nChoice := Alert( cMessage + ;
  149.                                                           ";(DOS Error " + NTRIM(e:osCode) + ")", ;
  150.                                                           aOptions )
  151.                   end
  152.  
  153.  
  154.                   if ( nChoice == NIL )
  155.                           exit
  156.                   end
  157.  
  158.           end
  159.  
  160.  
  161.           if ( !Empty(nChoice) )
  162.  
  163.                   // do as instructed
  164.                   if ( aOptions[nChoice] == "Break" )
  165.                           Break(e)
  166.  
  167.                   elseif ( aOptions[nChoice] == "Retry" )
  168.                           return (.t.)
  169.  
  170.                   elseif ( aOptions[nChoice] == "Default" )
  171.                           return (.f.)
  172.  
  173.                   end
  174.  
  175.           end
  176.  
  177.  
  178.           // display message and traceback
  179.           if ( !Empty(e:osCode) )
  180.                   cMessage += " (DOS Error " + NTRIM(e:osCode) + ") "
  181.           end
  182.  
  183.  
  184.         endif  //abort enhancement.
  185.  
  186.  
  187.         cMessage+=" "
  188.         cDateTime:="Date="+DtoC(Date())+"  Time="+Time()+" "
  189.  
  190.         ? "UserID="+UserID()+" "
  191.         if !Empty(NetName());  ? "Net_name="+NetName()+" ";  endif
  192.         ? cDateTime
  193.         ? cMessage
  194.         i := nFirstProc
  195.     while ( !Empty(ProcName(i)) )
  196.           ? "Called from", Trim(ProcName(i)) + "(" + NTRIM(ProcLine(i)) + ") "
  197.           i++
  198.     end
  199.  
  200.         //attempt out message into error file
  201.         ErrorLevel(1)
  202.  
  203.         LogOff()                        //work around crash test!
  204.         close all
  205.  
  206.         ErrorBlock( {|| __Quit()} )     //disable recursived call this proc. (force quit)
  207.  
  208.         if !Empty(ErrFile)
  209.  
  210.           if File(ErrFile)
  211.             fhandle:=FOpen(ErrFile,FO_WRITE)
  212.             FSeek(fhandle,0,FS_END)
  213.           else
  214.             fhandle:=FCreate(ErrFile,FC_NORMAL)
  215.           endif
  216.  
  217.           if fhandle<>F_ERROR
  218.  
  219.             FWrite(fhandle,"UserID="+UserID()+" "+CR_LF)
  220.             if !Empty(NetName()); FWrite(fhandle,"Net_name="+NetName()+" "+CR_LF); endif
  221.             FWrite(fhandle,cDateTime+CR_LF)
  222.             FWrite(fhandle,cMessage+CR_LF)
  223.  
  224.             i := nFirstProc
  225.             while ( !Empty(ProcName(i)) )
  226.               FWrite(fhandle, "Called from "+AllTrim(ProcName(i))+"("+NTRIM(ProcLine(i))+") "+CR_LF )
  227.               i++
  228.             end
  229.  
  230.             FWrite(fhandle,CR_LF)
  231.             FClose(fhandle)
  232.  
  233.           endif
  234.  
  235.         endif
  236.  
  237.     // give up
  238.     QUIT
  239.  
  240. return (.f.)
  241.  
  242.  
  243.  
  244.  
  245. /***
  246. *    ErrorMessage()
  247. */
  248. function ErrorMessage(e)
  249. local cMessage
  250.  
  251.  
  252.     // start error message
  253.         cMessage := if( e:severity > ES_WARNING, "Error", "Warning" )
  254.         cMessage += " CLIPPER/"
  255.  
  256.  
  257.     // add subsystem name if available
  258.     if ( ValType(e:subsystem) == "C" )
  259.         cMessage += e:subsystem()
  260.     else
  261.         cMessage += "???"
  262.     end
  263.  
  264.  
  265.     // add subsystem's error code if available
  266.     if ( ValType(e:subCode) == "N" )
  267.         cMessage += ("/" + NTRIM(e:subCode))
  268.     else
  269.         cMessage += "/???"
  270.     end
  271.  
  272.  
  273.     // add error description if available
  274.     if ( ValType(e:description) == "C" )
  275.         cMessage += ("  " + e:description)
  276.     end
  277.  
  278.  
  279.     // add either filename or operation
  280.     if ( !Empty(e:filename) )
  281.         cMessage += (": " + e:filename)
  282.  
  283.     elseif ( !Empty(e:operation) )
  284.         cMessage += (": " + e:operation)
  285.  
  286.     end
  287.  
  288.  
  289. return (cMessage)
  290.  
  291.  
  292.  
  293.  
  294. function SetErrFile( FName )
  295.   local OFName:=ErrFile
  296.   if FName<>nil;  ErrFile:=FName;  endif
  297.   return(OFName)
  298.  
  299. //.......................................................... eof ..............
  300.  
  301.